EnigmA Amiga Run 1996 February/EnigmA AMIGA RUN 04 (1996)(G.R. Edizioni)(IT)[!][issue 1996-02][Skylink CD III].iso/earcd/midi/rustle.lha/Rustle/Source/Rustle.mod

Text File | 1995-12-02 | 12KB | 453 lines

(**************************************************************************

:Remark.            Format: ein TAB in jeder 3. Spalte: ..tab..tab..tab..


:Program.        Rustle

:Contents.        plays white noise

:Bugs.            "Shit happens." (Murphy)


:Copyright.        Freeware---you may copy and use it, but all rights remain
:Copyright.        at the author

:Author.            Thomas Ansorge

:Address.        Dinkelackerring 55, 67435 Neustadt, Deutschland, Europa


:Language.        Modula-2

:Translator.    M2Amiga V4.3 (deutsch)


:History.        1.0 as of 22-Apr-95: seems to work...


**************************************************************************)

(*$ DEFINE DEBUG := FALSE *)


MODULE Rustle;

FROM Arts IMPORT Assert, BreakPoint, returnVal, Terminate, wbStarted;

FROM Audio IMPORT allocate, allocFailed, audioName, channelStolen, free, IOAudio, IOAudioPtr, lock, noWait, pervol;

FROM DosD IMPORT ctrlC, fail, RDArgsPtr;

FROM DosL IMPORT Delay, FreeArgs, ReadArgs;

FROM ExecD IMPORT IOFlagSet, IORequest, MemReqs, MemReqSet, MsgPort, Message, MessagePtr, MsgPortPtr, Node, write;

FROM ExecL IMPORT AbortIO, AllocMem, CloseDevice, CopyMem, CreateMsgPort, DeleteMsgPort, execVersion, FindTask, FreeMem, GetMsg, OpenDevice, Signal, Wait;

FROM ExecSupport IMPORT BeginIO;

FROM GraphicsD IMPORT DisplayFlags, DisplayFlagSet, GfxBase, GfxBasePtr;

FROM GraphicsL IMPORT graphicsBase;

(*
Es muß nicht \source{Randoms} sein, jeder Zufallszahlengenerator sollte es tun...
*)

FROM Randoms IMPORT Rand0, ReduceToByte;

FROM SYSTEM IMPORT ADDRESS, ADR, CAST, LONGSET, SHIFT, SHORTSET;

FROM Terminal IMPORT WriteLn, WriteString;

(* --------------------------------------------------------------------- *)

CONST
    prog_str = "Rustle 1.0/";
    date_str = "(22.04.95)";

    (*$ IF M68881 OR M68040 *)
        ver_str = prog_str + "68020+FPU " + date_str;
    (*$ ELSIF M68020 *)
        ver_str = prog_str + "68020 " + date_str;
    (*$ ELSIF M68010 *)
        ver_str = prog_str + "68010 " + date_str;
    (*$ ELSE *)
        ver_str = prog_str + "68000 " + date_str;
    (*$ ENDIF *)

    ver_ptr = ADR ("$VER: " + ver_str);

CONST
    exec_min_version = 36;

CONST
    rustle_buffer_size = 32 * 1024; (* Bytes *)

    frequency = 400 * 5000; (* 5000? *)

CONST
    template = "VOLUME/N";

TYPE
    ChannelArray = ARRAY [0..1] OF SHORTSET;

CONST
    left_channels = ChannelArray {SHORTSET {1}, SHORTSET {2}};
    right_channels = ChannelArray {SHORTSET {0}, SHORTSET {3}};

TYPE
    Status = (doing_nothing, allocating, playing, freeing, quitting);
    Location = (back_home, outside);

    IOAudioRec = RECORD
        io: IOAudio;
        status: Status;
        location: Location;
    END; (* RECORD IOAudioRec *)

    IOAudioRecPtr = POINTER TO IOAudioRec;

VAR
    (* Pointer *)
    data_ptr: ADDRESS;
    dummy_msg_ptr: IOAudioRecPtr;
    play_port_ptr: MsgPortPtr;
    rdargs_ptr: RDArgsPtr;
    vol: LONGINT;
    vol_ptr: POINTER TO LONGINT;

    (* anderes 32bit Zeug *)
    ctrlc_sig: LONGSET;
    play_sig: LONGSET;
    sigs: LONGSET;

    (* anderes *)
    alloc_key: INTEGER;
    left_play_req: IOAudioRec;
    right_play_req: IOAudioRec;

VAR (* Flags *)
    audio_open := BOOLEAN {FALSE};
    quit := BOOLEAN {FALSE};
    runtime_error := BOOLEAN {TRUE};

(* --------------------------------------------------------------------- *)

PROCEDURE Err (condition: BOOLEAN; msg: ARRAY OF CHAR); FORWARD;

(* --------------------------------------------------------------------- *)

PROCEDURE AbortChannel (VAR play_rec: IOAudioRec);

    BEGIN (* Prozedur AbortChannel *)

    IF play_rec.location = outside THEN
        AbortIO (ADR (play_rec));

    ELSE (* IF play_req.location = outside THEN *)
        Err (FALSE, ver_str + ": message not in use!");
    END; (* IF play_req.location = outside THEN *)
END AbortChannel; (* Prozedur *)

(* --------------------------------------------------------------------- *)

PROCEDURE AllocChannel (VAR play_req: IOAudioRec; channels: ChannelArray; key: INTEGER);

    (* play_req MUSS VAR sein wegen ADR (play_req) weiter unten!!! *)

    BEGIN (* Prozedur AllocChannel *)
        IF play_req.location = back_home THEN
            play_req.io.request.message.node.pri := -100;
            play_req.io.request.unit := NIL;
            play_req.io.request.command := allocate;
            play_req.io.request.flags := noWait;
            play_req.io.request.error := 0;
            play_req.io.allocKey := key;
            play_req.io.data := ADR (channels);
            play_req.io.length := SIZE (channels);
            play_req.io.period := 0;
            play_req.io.volume := 0;
            play_req.io.cycles := 0;

            play_req.status := allocating;
            play_req.location := outside;

            BeginIO (ADR (play_req));

        ELSE (* IF play_req.location = back_home THEN *)
            Err (FALSE, ver_str + ": message already in use!");
        END; (* IF play_req.location = back_home THEN *)
    END AllocChannel; (* Prozedur *)

(* --------------------------------------------------------------------- *)

(*
Diese Prozedur bricht das Programm sauber und kontextabhängig (Workbench oder
CLI) ab, falls \source{condition = FALSE}. Dabei wird \source{msg} als Fehlertext
ausgegeben.
*)

PROCEDURE Err (condition: BOOLEAN; msg: ARRAY OF CHAR);

    BEGIN (* Prozedur Err *)

    IF wbStarted THEN
        Assert (condition, ADR (msg));

    ELSE (* IF wbStarted *)
        IF NOT condition THEN
            WriteString (msg);
            WriteLn;

            returnVal := fail;
            Terminate ();
        END; (* If NOT condition *)
    END; (* IF wbStarted *)
END Err; (* Prozedur *)

(* --------------------------------------------------------------------- *)

PROCEDURE HandlePlayMessage (VAR play_req: IOAudioRec; channels: ChannelArray; key: INTEGER);

    (* play_req MUSS VAR sein wegen ADR (...) weiter unten!!! *)

    (* global: data_ptr *)

    (* ------------------------------------------------------------------ *)

    PROCEDURE GetAudioConstant (): LONGCARD;

        BEGIN (* Funktion GetAudioConstant *)

        IF pal IN graphicsBase^.displayFlags THEN
            RETURN 3546895;

        ELSE (* IF pal IN graphicsBase^.displayFlags *)
            RETURN 3579545;
        END; (* IF pal IN graphicsBase^.displayFlags THEN ELSE *)
    END GetAudioConstant; (* Funktion *)

    (* ------------------------------------------------------------------ *)

    BEGIN (* Prozedur HandlePlayMessage *)

    CASE play_req.status OF
        |allocating:
            IF play_req.location = back_home THEN
                IF play_req.io.request.error = 0 THEN
                    WITH  play_req.io DO
                        request.command := write;
                        request.flags := pervol; (* = 12, SHORTSET {3, 2} *)
                        data := data_ptr;
                        length := rustle_buffer_size;
                        period := GetAudioConstant () DIV frequency;

                        IF vol_ptr # NIL THEN
                            volume := vol_ptr^;

                        ELSE (* IF vol_ptr # NIL *)
                            volume := 4;
                        END; (* IF vol_ptr # NIL THEN ELSE *)

                        cycles := 0;
                    END; (* WITH  play_req.io.request *)

                    play_req.status := playing;
                    play_req.location := outside;

                    BeginIO (ADR (play_req));

                ELSIF play_req.io.request.error = allocFailed THEN
                    IF NOT quit THEN
                        Delay (100);
                        AllocChannel (play_req, channels, key);

                    ELSE (* IF NOT quit THEN *)
                        play_req.status := quitting;
                    END; (* IF NOT quit THEN *)

                ELSE (* IF play_req.io.request.error = 0 *)
                    Err (FALSE, ver_str + ": allocation failed!");
                END; (* IF play_req.io.request.error = 0 *)

            ELSE (* IF play_req.location = back_home THEN *)
                Err (FALSE, ver_str + ": message already in use!");
            END; (* IF play_req.location = back_home THEN *)

        |playing:
            IF NOT quit THEN
                AllocChannel (play_req, channels, key);

            ELSE (* IF NOT quit THEN *)
                play_req.status := quitting;
            END; (* IF NOT quit ELSE *)
    END; (* CASE play_req.status OF *)
END HandlePlayMessage; (* Prozedur *)

(* --------------------------------------------------------------------- *)

(*
Für weißes Rauschen brauchen wir einen zufällig gefüllten Bereich CHIP-Speicher.
*)

PROCEDURE InitRustleBuffer (): ADDRESS;

    TYPE
        RustleBuffer = ARRAY [1..rustle_buffer_size] OF SHORTCARD;
        RustleBufferPtr = POINTER TO RustleBuffer;

    VAR
        buffer_ptr: RustleBufferPtr;

        i: [1..rustle_buffer_size];

    BEGIN (* Funktion InitRustleBuffer *)
        buffer_ptr := AllocMem (rustle_buffer_size, MemReqSet {public, chip});
        Err (buffer_ptr # NIL, ver_str + ": no chip memory, no rustle.");

        FOR i := 1 TO rustle_buffer_size DO
            buffer_ptr^ [i] := ReduceToByte (Rand0 ());
        END; (* FOR i := 1 TO rustle_buffer_size *)

        RETURN buffer_ptr;
    END InitRustleBuffer; (* Funktion *)

(* --------------------------------------------------------------------- *)
(* --------------------------------------------------------------------- *)

BEGIN (* Program Rustle *)
    Err (execVersion >= exec_min_version, ver_str + ": Kickstart 2.0 Minimum!");

    IF wbStarted THEN
    ELSE (* IF wbStarted *)
        rdargs_ptr := ReadArgs (ADR (template), ADR (vol_ptr), NIL);
    END; (* IF wbStarted ELSE *)

    IF vol_ptr # NIL THEN
        IF (vol_ptr^ < 0) OR (vol_ptr^ > 64) THEN
            WriteString (ver_str + ": 0 <= VOLUME <= 64, using default (4)");
            WriteLn;

            vol_ptr := NIL;
        END; (* IF (vol_ptr^ < 0) OR (vol_ptr^ > 64) THEN *)
    END; (* IF vol_ptr # NIL THEN *)

    data_ptr := InitRustleBuffer ();

    ctrlc_sig := CAST (LONGSET, SHIFT (LONGINT (1), ctrlC));

    play_port_ptr := CreateMsgPort ();
    Err (play_port_ptr # NIL, ver_str + ": no message port to open Audio.device!");
    play_sig := CAST (LONGSET, SHIFT (LONGINT (1), play_port_ptr^.sigBit));

    left_play_req.io.request.message.replyPort := play_port_ptr;

    OpenDevice (ADR (audioName), 0, ADR (left_play_req.io), LONGSET {});
    Err (left_play_req.io.request.error = 0, ver_str + ": Audio.device did not open!");
    audio_open := TRUE;

    CopyMem (ADR (left_play_req), ADR (right_play_req), SIZE (left_play_req));

    alloc_key := left_play_req.io.allocKey;

    left_play_req.location := back_home;
    right_play_req.location := back_home;

    REPEAT
        IF left_play_req.status = doing_nothing THEN
            AllocChannel (left_play_req, left_channels, alloc_key);
        END; (* IF left_play_req.status = doing_nothing *)

(*
Solange wir keinen \source{allocKey} vom Audio-Device haben, dürfen wir nur
den einen Kanal alloziieren und müssen warten, bis wir ihn haben.
*)

        IF alloc_key # 0 THEN
            IF right_play_req.status = doing_nothing THEN
                AllocChannel (right_play_req, right_channels, alloc_key);
            END; (* IF right_play_req.status = doing_nothing *)
        END; (* IF alloc_key # 0 *)

        sigs := Wait (ctrlc_sig + play_sig);

(*
Ein Play-Request kam zurück. Normalerweise passiert das hier nur in den
folgenden Fällen:\begin{itemize}
\item Ein Kanal wurde gerade (hoffentlich) erfolgreich alloziiert.
\item Ein Kanal wurde uns genommen.
\item Ein Kanal wurde mit \source{AbortIO ()} abgebrochen.
\end{itemize}
*)

        IF play_sig <= sigs THEN
            dummy_msg_ptr := GetMsg (play_port_ptr);

            IF dummy_msg_ptr # NIL THEN
                Signal (FindTask (NIL), play_sig);

                IF alloc_key = 0 THEN
                    alloc_key := dummy_msg_ptr^.io.allocKey;
                END; (* IF alloc_key = 0 THEN *)

                dummy_msg_ptr^.location := back_home;

                IF dummy_msg_ptr = ADR (left_play_req) THEN
                    HandlePlayMessage (left_play_req, left_channels, alloc_key);

                ELSIF dummy_msg_ptr = ADR (right_play_req) THEN
                    HandlePlayMessage (right_play_req, right_channels, alloc_key);

                ELSE (* Hey, was ist das bloß für eine Nachricht??? *)
                    Err (FALSE, ver_str + ": got unexpected message (???)");
                END; (* ELSIF dummy_msg_ptr = ADR (right_play_req) ELSE *)
            END; (* IF dummy_msg_ptr # NIL *)
        END; (* IF play_sig <= sigs *)

(*
Control-C? Wenn ja, Schleife verlassen, aufräumen, Programm beenden.
*)

        IF ctrlc_sig <= sigs THEN
            WriteString ("***Break");
            WriteLn;

            AbortChannel (left_play_req);
            AbortChannel (right_play_req);

            quit := TRUE;

            (*$ IF DEBUG *)
            Terminate ();
            (*$ ENDIF *)
        END; (* IF ctrlc_sig <= sigs *)
    UNTIL (left_play_req.status = quitting) AND (right_play_req.status = quitting);

    runtime_error := FALSE;

CLOSE; (* -------------------------------------------------------------- *)
    IF NOT runtime_error THEN
        IF audio_open THEN
            CloseDevice (ADR (left_play_req.io));
            audio_open := FALSE;
        END; (* IF audio_open *)

        IF play_port_ptr # NIL THEN
            DeleteMsgPort (play_port_ptr);
            play_port_ptr := NIL;
        END; (* IF play_port_ptr # NIL *)

        IF data_ptr # NIL THEN
            FreeMem (data_ptr, rustle_buffer_size);
            data_ptr := NIL;
        END; (* IF data_ptr # NIL *)
    END; (* IF NOT runtime_error THEN *)

    IF rdargs_ptr # NIL THEN
        FreeArgs (rdargs_ptr);
        rdargs_ptr := NIL;
    END; (* IF rdargs_ptr # NIL THEN *)
END Rustle.